perm filename MUCODE.LSP[SCH,LSP] blob
sn#688835 filedate 1982-11-14 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00030 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 -*-LISP-*-
C00003 00003
C00007 00004
C00010 00005
C00012 00006
C00016 00007
C00018 00008
C00021 00009
C00024 00010
C00028 00011
C00030 00012
C00033 00013
C00036 00014
C00039 00015
C00043 00016
C00046 00017
C00050 00018
C00053 00019
C00056 00020
C00060 00021
C00063 00022
C00067 00023
C00070 00024
C00074 00025
C00078 00026
C00082 00027
C00086 00028
C00090 00029
C00092 00030
C00096 ENDMK
C⊗;
;;; -*-LISP-*-
(HERALD MUCODE "")
(eval-when (compile) (load "umacro.lsp"))
(eval-when (compile) (load "smacro.lsp"))
(eval-when (compile) ;Used in DEFCONT-WITH-FORCED-VAL
(DEFUN CONCAT N
(LET ((L (LISTIFY N)))
(COND ((< (LENGTH L) 2)
(CAR L))
(T
(IMPLODE (MAPCAN 'EXPLODEC L)))))))
;;;; DEC20 SCHEME "Microcode"
;;; The following code is the definition of the interpreter for SCHEME
;;; S-code. It is written as a "machine-language" for the SCHEME virtual
;;; machine.
(DECLARE (*LEXPR BUG-SCHEME-ERROR))
;;;; racks
;;; The SCHEME virtual machine is composed of a set of registers with
;;; associated stacks (RACKS) and a controller. The following allows
;;; one to set up the RACKS.
(DECLARE (SPECIAL RACK-NUMBER *RACK-STATS?))
(eval-when (compile load eval) ;for some reason, LM needs it
(DEFMACRO DEFRACK (NAME TYPE)
`(PROGN 'COMPILE
(PUTPROP ',NAME RACK-NUMBER 'RACK-NUMBER)
(PUTPROP ',NAME ',TYPE 'RACK-TYPE)
(SETQ RACK-NUMBER (1+ RACK-NUMBER))))
)
;;; Rack primitive operations are generic on rack type.
(DEFMACRO FETCH (RACKNAME)
(FUNCALL (OR (GET (GET RACKNAME 'RACK-TYPE) 'FETCH)
(ERROR "Unknown rack type -- FETCH" RACKNAME))
RACKNAME))
(DEFMACRO ASSIGN (RACKNAME EXP)
(FUNCALL (OR (GET (GET RACKNAME 'RACK-TYPE) 'ASSIGN)
(ERROR "Unknown rack type -- ASSIGN" RACKNAME))
RACKNAME
EXP))
(DEFMACRO SAVE (RACKNAME)
(FUNCALL (OR (GET (GET RACKNAME 'RACK-TYPE) 'SAVE)
(ERROR "Unknown rack type -- SAVE" RACKNAME))
RACKNAME))
(DEFMACRO RESTORE (RACKNAME)
(FUNCALL (OR (GET (GET RACKNAME 'RACK-TYPE) 'RESTORE)
(ERROR "Unknown rack type -- RESTORE" RACKNAME))
RACKNAME))
(DEFMACRO GET-STATE (RACKNAME)
(FUNCALL (OR (GET (GET RACKNAME 'RACK-TYPE) 'GET-STATE)
(ERROR "Unknown rack type -- GET-STATE" RACKNAME))
RACKNAME))
(DEFMACRO SET-STATE (RACKNAME STATE)
(FUNCALL (OR (GET (GET RACKNAME 'RACK-TYPE) 'SET-STATE)
(ERROR "Unknown rack type -- SET-STATE" RACKNAME))
RACKNAME
STATE))
(DEFMACRO SAVE-AFTER-ASSIGN (RACKNAME EXP)
(FUNCALL (OR (GET (GET RACKNAME 'RACK-TYPE) 'SAVE-AFTER-ASSIGN)
(ERROR "Unknown rack type -- SAVE-AFTER-ASSIGN" RACKNAME))
RACKNAME
EXP))
(DEFMACRO ASSIGN-AFTER-RESTORE (RACKNAME EXP)
(FUNCALL (OR (GET (GET RACKNAME 'RACK-TYPE) 'ASSIGN-AFTER-RESTORE)
(ERROR "Unknown rack type -- ASSIGN-AFTER-RESTORE" RACKNAME))
RACKNAME
EXP))
(DEFMACRO RESTORE-ASSIGN-SAVE (RACKNAME EXP)
(FUNCALL (OR (GET (GET RACKNAME 'RACK-TYPE) 'RESTORE-ASSIGN-SAVE)
(ERROR "Unknown rack type -- RESTORE-ASSIGN-SAVE" RACKNAME))
RACKNAME
EXP))
(EVAL-WHEN (EVAL COMPILE LOAD)
;;; Simple register primitives.
(DEFUN (SIMPLE-REGISTER FETCH) (R)
`(READ-REG ,R))
(DEFUN (SIMPLE-REGISTER ASSIGN) (R V)
`(LOAD-REG ,R ,V))
;;; Push optimizer primitives.
(DEFMACRO PUSH-OPTIMIZER-ASSIGN-PREPARATION (R)
`(COND ((NOT (FREE-RACK? ,R))
(PUSH-RACK ,R)
(FREE-RACK! ,R))))
(DEFUN (PUSH-OPTIMIZER FETCH) (R)
`(READ-REG ,R))
(DEFUN (PUSH-OPTIMIZER ASSIGN) (R V)
`(PROGN (PUSH-OPTIMIZER-ASSIGN-PREPARATION ,R)
(LOAD-REG ,R ,V)))
(DEFUN (PUSH-OPTIMIZER SAVE) (R)
`(COND ((NOT (FREE-RACK? ,R))
(PUSH-RACK ,R))
(T (MARK-SAVED! ,R))))
(DEFUN (PUSH-OPTIMIZER RESTORE) (R)
`(COND ((FREE-RACK? ,R)
(POP-RACK ,R))
(T (FREE-RACK! ,R))))
(DEFUN (PUSH-OPTIMIZER GET-STATE) (R)
`(PROGN (PUSH-OPTIMIZER-ASSIGN-PREPARATION ,R)
(READ-STACK ,R)))
(DEFUN (PUSH-OPTIMIZER SET-STATE) (R S)
`(LOAD-STACK ,R ,S))
(DEFUN (PUSH-OPTIMIZER SAVE-AFTER-ASSIGN) (R V)
`(COND ((NOT (FREE-RACK? ,R))
(PUSH-RACK ,R)
(LOAD-REG ,R ,V))
(T
(LOAD-REG ,R ,V)
(MARK-SAVED! ,R))))
(DEFUN (PUSH-OPTIMIZER ASSIGN-AFTER-RESTORE) (R V)
`(COND ((FREE-RACK? ,R)
(POP-RACK ,R)
(LOAD-REG ,R ,V))
(T
(FREE-RACK! ,R)
(LOAD-REG ,R ,V))))
(DEFUN (PUSH-OPTIMIZER RESTORE-ASSIGN-SAVE) (R V)
`(COND ((FREE-RACK? ,R)
(POP-RACK ,R)
(LOAD-REG ,R ,V)
(MARK-SAVED! ,R))
(T
(LOAD-REG ,R ,V))))
;;; Push counter primitives.
(DEFMACRO PUSH-COUNTER-ASSIGN-PREPARATION (R)
`(COND ((NOT (FREE-RACK? ,R))
(PUSH-COUNT ,R)
(PUSH-RACK ,R)
(FREE-RACK! ,R))))
(DEFUN (PUSH-COUNTER FETCH) (R)
`(READ-REG ,R))
(DEFUN (PUSH-COUNTER ASSIGN) (R V)
`(PROGN (PUSH-COUNTER-ASSIGN-PREPARATION ,R)
(LOAD-REG ,R ,V)))
(DEFUN (PUSH-COUNTER SAVE) (R)
`(INCREMENT-COUNT ,R))
(DEFUN (PUSH-COUNTER RESTORE) (R)
`(PROGN (COND ((FREE-RACK? ,R)
(POP-RACK ,R)
(POP-COUNT ,R)))
(DECREMENT-COUNT ,R)))
(DEFUN (PUSH-COUNTER GET-STATE) (R)
`(PROGN (PUSH-COUNTER-ASSIGN-PREPARATION ,R)
(READ-STACK ,R)))
(DEFUN (PUSH-COUNTER SET-STATE) (R S)
`(LOAD-STACK ,R ,S))
)
;;; Abstract register/stack operations implemented in hunks.
(DECLARE (SPECIAL *THE-REGISTERS *THE-STACKS *FREE-MARKS *RACK-STATS))
(DEFMACRO READ-REG (R)
`(CXR ,(GET R 'RACK-NUMBER) *THE-REGISTERS))
(DEFMACRO LOAD-REG (R V)
`(RPLACX ,(GET R 'RACK-NUMBER) *THE-REGISTERS ,V))
(DEFMACRO READ-STACK (R)
`(CXR ,(GET R 'RACK-NUMBER) *THE-STACKS))
(DEFMACRO LOAD-STACK (R V)
`(RPLACX ,(GET R 'RACK-NUMBER) *THE-STACKS ,V))
(DEFMACRO FREE-RACK? (R)
`(= (CXR ,(GET R 'RACK-NUMBER) *FREE-MARKS) 0))
(DEFMACRO FREE-RACK! (R)
`(RPLACX ,(GET R 'RACK-NUMBER) *FREE-MARKS 0))
(DEFMACRO MARK-SAVED! (R)
`(RPLACX ,(GET R 'RACK-NUMBER) *FREE-MARKS 1))
(DEFMACRO PUSH-RACK (R)
(LET* ((N (GET R 'RACK-NUMBER))
(P `(RPLACX ,N *THE-STACKS
(CONS (CXR ,N *THE-REGISTERS)
(CXR ,N *THE-STACKS)))))
(COND (*RACK-STATS?
`(PROGN (RPLACX ,N *RACK-STATS (1+ (CXR ,N *RACK-STATS)))
,P))
(T P))))
(DEFMACRO POP-RACK (R)
(LET ((N (GET R 'RACK-NUMBER)))
`(PROGN (RPLACX ,N *THE-REGISTERS (CAR (CXR ,N *THE-STACKS)))
(RPLACX ,N *THE-STACKS (CDR (CXR ,N *THE-STACKS))))))
(DEFMACRO POP-RACK-STACK (R)
(LET ((N (GET R 'RACK-NUMBER)))
`(RPLACX ,N *THE-STACKS (CDR (CXR ,N *THE-STACKS)))))
(DEFMACRO PUSH-COUNT (R)
(LET ((N (GET R 'RACK-NUMBER)))
`(RPLACX ,N *THE-STACKS
(CONS (CXR ,N *FREE-MARKS)
(CXR ,N *THE-STACKS)))))
(DEFMACRO POP-COUNT (R)
(LET ((N (GET R 'RACK-NUMBER)))
`(PROGN (RPLACX ,N *FREE-MARKS (CAR (CXR ,N *THE-STACKS)))
(RPLACX ,N *THE-STACKS (CDR (CXR ,N *THE-STACKS))))))
(DEFMACRO INCREMENT-COUNT (R)
(LET ((N (GET R 'RACK-NUMBER)))
`(RPLACX ,N *FREE-MARKS (1+ (CXR ,N *FREE-MARKS)))))
(DEFMACRO DECREMENT-COUNT (R)
(LET ((N (GET R 'RACK-NUMBER)))
`(RPLACX ,N *FREE-MARKS (1- (CXR ,N *FREE-MARKS)))))
(DEFUN RESET-RACKS ()
(SETQ *THE-REGISTERS (MAKE-HUNK-OF-SIZE 16.))
(SETQ *THE-STACKS (MAKE-HUNK-OF-SIZE 16.))
(SETQ *FREE-MARKS (MAKE-HUNK-LIST '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)))
(COND ((NOT (NULL *RACK-STATS?))
(SETQ *RACK-STATS
(MAKE-HUNK-LIST '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))))))
;;;; description of the microcode machine
(EVAL-WHEN (EVAL COMPILE LOAD)
(SETQ RACK-NUMBER 0)
(SETQ *RACK-STATS? NIL)
;;; The SCHEME virtual machine defines the following basic racks.
;;; These registers need stacks to back them up.
(DEFRACK CONT PUSH-OPTIMIZER)
(DEFRACK ENV PUSH-COUNTER)
(DEFRACK UNEV PUSH-OPTIMIZER)
(DEFRACK ARGL PUSH-OPTIMIZER)
(DEFRACK DELAYED-OBJECT PUSH-OPTIMIZER)
(DEFRACK VCELL PUSH-OPTIMIZER)
;;; These registers need no stacks.
(DEFRACK EXP SIMPLE-REGISTER)
(DEFRACK VAL SIMPLE-REGISTER)
(DEFRACK WIND-FORMS SIMPLE-REGISTER)
(DEFRACK PENDING-INTERRUPTS SIMPLE-REGISTER)
(DEFRACK INTERRUPTS-ENABLED SIMPLE-REGISTER)
(DEFRACK INTERRUPT-VECTOR SIMPLE-REGISTER)
)
(include "hist.lsp")
;;;; controller macros
;;; The following macros allow us to refer to virtual machine entry points
;;; as the values of LISP variables.
(DEFVAR TOTAL-TIME 0)
(DEFVAR BTIME 0)
(DEFVAR BGTIME 0)
(DEFVAR OPC 'HALT)
;;; Timing analysis of implementation can be done with *SYSTEM-ANALYZE*
;;; set to T.
(EVAL-WHEN (COMPILE LOAD EVAL)
(DEFVAR *SYSTEM-ANALYZE* NIL)
(DEFVAR *TRACEABLE-MICROCODE* NIL))
;;; Simple jumps are notated with:
(DEFMACRO GOTO (PC)
(COND ((MEMQ 'COMPLR (STATUS FEATURES))
(IF *SYSTEM-ANALYZE*
`(PROGN (SETQ ETIME
(- (RUNTIME) BTIME (- (STATUS GCTIME) BGTIME)))
(PUTPROP OPC (+ ETIME (OR (GET OPC 'TIME) 0)) 'TIME)
(PUTPROP OPC (1+ (OR (GET OPC 'COUNT) 0)) 'COUNT)
(SETQ TOTAL-TIME (+ ETIME TOTAL-TIME))
(SETQ OPC ',PC)
(SETQ BTIME (RUNTIME) BGTIME (STATUS GCTIME))
(SUBRCALL NIL ,PC))
(IF (SYMBOLP PC)
(PROGN (EVAL `(SPECIAL ,PC))
(IF *TRACEABLE-MICROCODE*
`(SUBRCALL NIL ,PC)
`(,PC)))
`(SUBRCALL NIL ,PC))))
(T
`(FUNCALL ,PC))))
;;; Dispatches are notated with:
(DEFMACRO DISPATCH (REG DISPATCH-TYPE)
(COND ((MEMQ 'COMPLR (STATUS FEATURES))
(IF *SYSTEM-ANALYZE*
`(PROGN (SETQ ETIME
(- (RUNTIME) BTIME (- (STATUS GCTIME) BGTIME)))
(PUTPROP OPC (+ ETIME (OR (GET OPC 'TIME) 0)) 'TIME)
(PUTPROP OPC (1+ (OR (GET OPC 'COUNT) 0)) 'COUNT)
(SETQ TOTAL-TIME (+ ETIME TOTAL-TIME))
(SETQ OPC (TYPE (FETCH ,REG)))
(SETQ BTIME (RUNTIME) BGTIME (STATUS GCTIME))
(SUBRCALL NIL (SYMEVAL OPC)))
`(SUBRCALL NIL (SYMEVAL (TYPE (FETCH ,REG))))))
(T
`(FUNCALL (SYMEVAL (OR (TYPE (FETCH ,REG))
(BUG-SCHEME-ERROR "Unknown dispatch"
(LIST (FETCH ,REG)
',DISPATCH-TYPE))))))))
(DEFMACRO CONTINUE-EVALUATING-EXP ()
`(SET-HISTORY-TO-NEXT-REDUCTION))
(DEFMACRO EVAL-DISPATCH ()
'(PROGN (RECORD-EVALUATION-IN-HISTORY)
(DISPATCH EXP EXPRESSION-CLASS)))
;;; The following is a common sequence of operations used to initiate the
;;; evaluation of a subexpression. CONTINUATION is an interpreter
;;; procedure to go to with answer. When used as the last line of a body
;;; of microinstructions, a call to EVAL-DISPATCH is supplied by
;;; MAIN-LOOP.
(DEFMACRO EVAL-EXP-RESULT-TO (CONTINUATION)
`(PROGN (SETUP-CONTINUATION ,CONTINUATION)
(PUSH-HISTORY)
;;(EVAL-DISPATCH)
))
(DEFMACRO SETUP-CONTINUATION (CONTINUATION)
(IF (MEMQ 'COMPLR (STATUS FEATURES))
(EVAL `(SPECIAL ,CONTINUATION)))
`(SAVE-AFTER-ASSIGN CONT ,CONTINUATION))
;;; When an answer is developed, POPJ is used to go to
;;; the continuation which was set up (by EVAL-EXP-RESULT-TO)
;;; to receive the answer.
(DEFMACRO POPJ ()
'(PROGN (RESTORE CONT)
(POP-HISTORY)
(CONTINUE)))
(DEFMACRO CONTINUE ()
(COND ((MEMQ 'COMPLR (STATUS FEATURES))
(IF *SYSTEM-ANALYZE*
`(PROGN (SETQ ETIME
(- (RUNTIME) BTIME (- (STATUS GCTIME) BGTIME)))
(PUTPROP OPC (+ ETIME (OR (GET OPC 'TIME) 0)) 'TIME)
(PUTPROP OPC (1+ (OR (GET OPC 'COUNT) 0)) 'COUNT)
(SETQ TOTAL-TIME (+ ETIME TOTAL-TIME))
(SETQ OPC (SUBR-NAME (FETCH CONT)))
(SETQ BTIME (RUNTIME) BGTIME (STATUS GCTIME))
(SUBRCALL NIL (FETCH CONT)))
'(SUBRCALL NIL (FETCH CONT))))
(T
'(FUNCALL (FETCH CONT)))))
;;; Virtual machine entry points which are referred to are defined with:
(DEFMACRO DEFCONT (CNAME RACKS . BODY)
(LET ((PROC (COND ((MEMQ 'COMPLR (STATUS FEATURES))
`(GET ',CNAME 'SUBR))
(T
`',CNAME))))
`(PROGN 'COMPILE
(PUTPROP ',CNAME (LIST ',RACKS) 'RACKS)
(DEFUN ,CNAME () . ,BODY)
(SETQ ,CNAME ,PROC))))
;;; RACKS, the list of racks which should be popped from the control
;;; stack before a (POPJ) is executed, is provided for the debugger.
;;; Simple entry points, ie, targets of GOTOs only, are defined with:
(DEFMACRO DEFENTRY (CNAME RACKS . BODY)
(LET ((PROC (COND ((MEMQ 'COMPLR (STATUS FEATURES))
`(GET ',CNAME 'SUBR))
(T
`',CNAME))))
`(PROGN 'COMPILE
(PUTPROP ',CNAME (LIST ',RACKS) 'RACKS)
(DEFUN ,CNAME () . ,BODY)
(SETQ ,CNAME ,PROC))))
;;; Virtual machine dispatch targets are defined with:
(DEFMACRO DEFDISPATCH (CNAME DISPATCH-TYPE . BODY)
(LET ((PROC (COND ((MEMQ 'COMPLR (STATUS FEATURES))
`(GET (GET ',CNAME ',DISPATCH-TYPE) 'SUBR))
(T
`(GET ',CNAME ',DISPATCH-TYPE)))))
`(PROGN 'COMPILE
(DEFUN (,CNAME ,DISPATCH-TYPE) () . ,BODY)
(SETQ ,CNAME ,PROC))))
(DEFMACRO DEFCONT-WITH-FORCED-VAL (NAME SAVED . BODY)
(LET ((FORCE-RETURN (CONCAT NAME '- 'FORCE-RETURN)))
`(PROGN 'COMPILE
(DEFCONT ,FORCE-RETURN ,SAVED
(RESTORE DELAYED-OBJECT)
(SET-FORCED-VALUE (FETCH DELAYED-OBJECT) (FETCH VAL))
(GOTO ,NAME))
(DEFCONT ,NAME ,SAVED
(COND ((DELAYED? (FETCH VAL))
(COND ((ALREADY-FORCED? (FETCH VAL))
(ASSIGN VAL (FORCED-VALUE (FETCH VAL)))
(GOTO ,NAME))
(T
(SAVE-AFTER-ASSIGN DELAYED-OBJECT (FETCH VAL))
(ASSIGN ENV (DELAYED-ENVIRONMENT (FETCH VAL)))
(ASSIGN EXP (DELAYED-EXPRESSION (FETCH VAL)))
(EVAL-EXP-RESULT-TO ,FORCE-RETURN))))
(T
,@BODY))))))
;;;; variable reference "microcode"
(DEFDISPATCH LEXICAL-UNCOMPILED EXPRESSION-CLASS
(ASSIGN VCELL (SETUP-LEXICAL-ADDRESS (VARSPEC (FETCH EXP)))) ;Compiles
(COND ((NULL (FETCH VCELL))
(EVAL-ERROR "Unbound variable referenced" (VARSPEC (FETCH EXP))))
(T
(ASSIGN VAL (INLOC (FETCH VCELL)))
(POPJ))))
(DEFDISPATCH LEXICAL-FORMAL EXPRESSION-CLASS
(ASSIGN VCELL (GET-FORMAL-VCELL (LEXICAL-ADDRESS (VARSPEC (FETCH EXP)))))
(COND ((NULL (FETCH VCELL))
(UNCOMPILE-LEXICAL (FETCH EXP))
;; (EVAL-DISPATCH)
)
(T
(ASSIGN VAL (INLOC (FETCH VCELL)))
(POPJ))))
(DEFDISPATCH LEXICAL-AUXILIARY EXPRESSION-CLASS
(ASSIGN VCELL (GET-AUXILIARY-VCELL (VARSPEC (FETCH EXP))))
(COND ((NULL (FETCH VCELL))
(UNCOMPILE-LEXICAL (FETCH EXP))
;; (EVAL-DISPATCH)
)
(T
(ASSIGN VAL (INLOC (FETCH VCELL)))
(POPJ))))
(DEFDISPATCH GLOBAL EXPRESSION-CLASS
(ASSIGN VCELL (GET-GLOBAL-VCELL (VARSPEC (FETCH EXP))))
(COND ((NULL (FETCH VCELL))
(UNCOMPILE-LEXICAL (FETCH EXP))
;; (EVAL-DISPATCH)
)
(T
(ASSIGN VAL (INLOC (FETCH VCELL)))
(POPJ))))
;;;; variable assignment
(DEFDISPATCH ASSIGN-UNCOMPILED EXPRESSION-CLASS
(ASSIGN VCELL (SETUP-LEXICAL-ADDRESS (ASSIGN-VARSPEC (FETCH EXP))))
(COND ((NULL (FETCH VCELL))
(EVAL-ERROR "Unbound variable assigned" (ASSIGN-VARSPEC (FETCH EXP))))
(T
(SAVE VCELL)
(ASSIGN EXP (ASSIGN-VALUE (FETCH EXP)))
(EVAL-EXP-RESULT-TO ASSIGN-RETURN))))
(DEFDISPATCH ASSIGN-FORMAL EXPRESSION-CLASS
(ASSIGN VCELL
(GET-FORMAL-VCELL (LEXICAL-ADDRESS (ASSIGN-VARSPEC (FETCH EXP)))))
(COND ((NULL (FETCH VCELL))
(UNCOMPILE-LEXICAL (FETCH EXP))
;; (EVAL-DISPATCH)
)
(T
(SAVE VCELL)
(ASSIGN EXP (ASSIGN-VALUE (FETCH EXP)))
(EVAL-EXP-RESULT-TO ASSIGN-RETURN))))
(DEFDISPATCH ASSIGN-AUXILIARY EXPRESSION-CLASS
(ASSIGN VCELL
(GET-AUXILIARY-VCELL (ASSIGN-VARSPEC (FETCH EXP))))
(COND ((NULL (FETCH VCELL))
(UNCOMPILE-LEXICAL (FETCH EXP))
;; (EVAL-DISPATCH)
)
(T
(SAVE VCELL)
(ASSIGN EXP (ASSIGN-VALUE (FETCH EXP)))
(EVAL-EXP-RESULT-TO ASSIGN-RETURN))))
(DEFDISPATCH ASSIGN-GLOBAL EXPRESSION-CLASS
(ASSIGN VCELL (GET-GLOBAL-VCELL (ASSIGN-VARSPEC (FETCH EXP))))
(COND ((NULL (FETCH VCELL))
(UNCOMPILE-LEXICAL (FETCH EXP))
;; (EVAL-DISPATCH)
)
(T
(SAVE VCELL)
(ASSIGN EXP (ASSIGN-VALUE (FETCH EXP)))
(EVAL-EXP-RESULT-TO ASSIGN-RETURN))))
(DEFCONT ASSIGN-RETURN (VCELL)
(RESTORE VCELL)
(SETLOC (FETCH VCELL) (FETCH VAL))
(POPJ))
;;;; special forms
(DEFDISPATCH QUOTED EXPRESSION-CLASS
(ASSIGN VAL (TEXT-OF-QUOTATION (FETCH EXP)))
(POPJ))
(DEFDISPATCH DELAYED EXPRESSION-CLASS
(ASSIGN VAL (MAKE-DELAYED (DELAYED-CORPUS (FETCH EXP)) (FETCH ENV)))
(POPJ))
(DEFDISPATCH PROCEDURE-DEFINITION EXPRESSION-CLASS
(ASSIGN VAL (MAKE-PROCEDURE (FETCH EXP) (FETCH ENV)))
(POPJ))
(DEFDISPATCH THE-ENVIRONMENT EXPRESSION-CLASS
(ASSIGN VAL (FETCH ENV))
(POPJ))
(DEFDISPATCH THE-ARGUMENTS EXPRESSION-CLASS ; *** ?
(ASSIGN VAL (FRAME-ARGUMENTS (FETCH ENV)))
(POPJ))
(DEFDISPATCH IF-THEN-ELSE EXPRESSION-CLASS
(SAVE ENV)
(SAVE-AFTER-ASSIGN UNEV (FETCH EXP))
(ASSIGN EXP (PREDICATE-PART (FETCH EXP)))
(EVAL-EXP-RESULT-TO IF-THEN-ELSE-RETURN))
(DEFCONT-WITH-FORCED-VAL IF-THEN-ELSE-RETURN (UNEV ENV)
(RESTORE UNEV)
(RESTORE ENV)
(COND ((TRUE? (FETCH VAL))
(ASSIGN EXP (CONSEQUENT (ALTERNATIVES (FETCH UNEV))))
(CONTINUE-EVALUATING-EXP)
;; (EVAL-DISPATCH)
)
((NO-ALTERNATIVE? (ALTERNATIVES (FETCH UNEV)))
(POPJ))
(T
(ASSIGN EXP (ALTERNATIVE (ALTERNATIVES (FETCH UNEV))))
(CONTINUE-EVALUATING-EXP)
;; (EVAL-DISPATCH)
))))
(DEFDISPATCH UNLESS EXPRESSION-CLASS
(SAVE ENV)
(SAVE-AFTER-ASSIGN UNEV (FETCH EXP))
(ASSIGN EXP (UNLESS-FIRST (FETCH EXP)))
(EVAL-EXP-RESULT-TO UNLESS-DECIDE))
(DEFCONT-WITH-FORCED-VAL UNLESS-DECIDE (UNEV ENV)
(RESTORE UNEV)
(RESTORE ENV)
(COND ((TRUE? (FETCH VAL))
(POPJ))
(T
(ASSIGN EXP (UNLESS-SECOND (FETCH UNEV)))
(CONTINUE-EVALUATING-EXP)
;; (EVAL-DISPATCH)
)))
(DEFDISPATCH SEQUENCE EXPRESSION-CLASS
(ASSIGN UNEV (EXPRESSIONS (FETCH EXP)))
(GOTO EVAL-SEQUENCE))
(DEFENTRY EVAL-SEQUENCE ()
(COND ((LAST-EXP? (FETCH UNEV))
(ASSIGN EXP (FIRST-EXP (FETCH UNEV)))
(CONTINUE-EVALUATING-EXP)
;;(EVAL-DISPATCH)
)
(T
(SAVE ENV)
(SAVE UNEV)
(ASSIGN EXP (FIRST-EXP (FETCH UNEV)))
(EVAL-EXP-RESULT-TO EVAL-SEQUENCE-RETURN))))
(DEFCONT EVAL-SEQUENCE-RETURN (UNEV ENV)
(ASSIGN-AFTER-RESTORE UNEV (REST-EXPS (FETCH UNEV)))
(RESTORE ENV)
(GOTO EVAL-SEQUENCE))
(DEFDISPATCH CONTROL-BINDER EXPRESSION-CLASS
(LET ((CP (MAKE-CONTROL-POINT)))
(ASSIGN ENV
(MAKE-ENVIRONMENT (MAKE-CONTROL-BINDER-PROCEDURE (FETCH EXP)
(FETCH ENV))
(LIST CP))))
(ASSIGN EXP (CONTROL-BINDER-BODY (FETCH EXP)))
(CONTINUE-EVALUATING-EXP)
;; (EVAL-DISPATCH)
)
(DEFDISPATCH DYNAMIC-WIND EXPRESSION-CLASS
(SAVE ENV)
(SAVE-AFTER-ASSIGN UNEV (FETCH EXP))
(ASSIGN EXP (ENTRY-FORM (FETCH EXP)))
(EVAL-EXP-RESULT-TO DYNAMIC-BODY))
(DEFCONT DYNAMIC-BODY (UNEV ENV)
(RESTORE UNEV)
(RESTORE ENV)
(ASSIGN WIND-FORMS
(CONS (CONS (FETCH UNEV) (FETCH ENV))
(FETCH WIND-FORMS)))
(ASSIGN EXP (CONTENT-FORM (FETCH UNEV)))
(EVAL-EXP-RESULT-TO AFTER-DYNAMIC-BODY))
(DEFCONT AFTER-DYNAMIC-BODY ()
(SAVE-AFTER-ASSIGN ARGL (FETCH VAL))
(ASSIGN EXP (UNWIND-FORM (CAR (FETCH WIND-FORMS))))
(ASSIGN ENV (DYNAMIC-ENV (CAR (FETCH WIND-FORMS))))
(ASSIGN WIND-FORMS (CDR (FETCH WIND-FORMS))) ;Pop WIND-FORMS.
(EVAL-EXP-RESULT-TO AFTER-DYNAMIC-UNWIND))
(DEFCONT AFTER-DYNAMIC-UNWIND (ARGL)
(RESTORE ARGL)
(ASSIGN VAL (FETCH ARGL))
(POPJ))
;;;; combinations
(DEFDISPATCH COMBINATION EXPRESSION-CLASS
(SAVE ENV)
(SAVE-AFTER-ASSIGN UNEV (EXPRESSIONS (FETCH EXP)))
(ASSIGN EXP (FIRST-EXP (FETCH UNEV)))
(EVAL-EXP-RESULT-TO EVAL-COMB-1))
(DEFCONT EVAL-COMB-1 (UNEV ENV)
(ASSIGN-AFTER-RESTORE UNEV (REST-EXPS (FETCH UNEV)))
(RESTORE ENV)
(SAVE-AFTER-ASSIGN ARGL (LIST (FETCH VAL)))
(ASSIGN EXP (FIRST-EXP (FETCH UNEV)))
(COND ((LAST-EXP? (FETCH UNEV))
(EVAL-EXP-RESULT-TO INTERNAL-APPLY))
(T
(SAVE ENV)
(SAVE UNEV)
(EVAL-EXP-RESULT-TO EVAL-COMB-3))))
(DEFCONT EVAL-COMB-3 (UNEV ENV ARGL)
(ASSIGN-AFTER-RESTORE UNEV (REST-EXPS (FETCH UNEV)))
(RESTORE ENV)
(RESTORE-ASSIGN-SAVE ARGL (CONS (FETCH VAL) (FETCH ARGL)))
(ASSIGN EXP (FIRST-EXP (FETCH UNEV)))
(COND ((LAST-EXP? (FETCH UNEV))
(EVAL-EXP-RESULT-TO INTERNAL-APPLY))
(T
(SAVE ENV)
(SAVE UNEV)
(EVAL-EXP-RESULT-TO EVAL-COMB-3))))
(DEFCONT-WITH-FORCED-VAL INTERNAL-APPLY (ARGL)
(RESTORE ARGL)
(COND ((APPLICABLE? (FETCH VAL))
(DISPATCH VAL PROCEDURE-CLASS))
(T
(APPLY-ERROR "Inapplicable procedure object"
(FETCH VAL)
(FETCH ARGL)))))
;;; Compiled code jumps here to apply a procedure. The interrupt handler
;;; procedures are applied here as well. The procedure
;;; object is in VAL and the parameters are in ARGL, but the EXP
;;; associated with the procedure object are not available.
(DEFENTRY INTERNAL-APPLY-DISPATCH ()
(COND ((APPLICABLE? (FETCH VAL))
(DISPATCH VAL PROCEDURE-CLASS))
(T
(APPLY-ERROR "Inapplicable procedure object"
(FETCH VAL)
(FETCH ARGL)))))
(DEFDISPATCH NO-OPERANDS EXPRESSION-CLASS
(ASSIGN EXP (FIRST-EXP (EXPRESSIONS (FETCH EXP))))
(EVAL-EXP-RESULT-TO EVAL-NO-OPERANDS))
(DEFCONT-WITH-FORCED-VAL EVAL-NO-OPERANDS ()
(ASSIGN ARGL '())
(COND ((APPLICABLE? (FETCH VAL))
(DISPATCH VAL EXPRESSION-CLASS))
(T
(APPLY-ERROR "Inapplicable procedure object"
(FETCH VAL)
(FETCH ARGL)))))
(DEFVAR *DEBUG* T)
;;; Applicators for interpretive compound procedures here.
(DEFMACRO WITH-CHECKARGS-COMPOUND BODY
`(COND ((AND *DEBUG*
(NOT (EQ (CAR (FORMAL-PARAMETERS (FETCH VAL)))
'&REST))) ; no checking if SCHEME LEXPR
(LET ((NARGS (LENGTH (FETCH ARGL)))
(NPARAMS (LENGTH (FORMAL-PARAMETERS (FETCH VAL)))))
(COND ((< NARGS NPARAMS)
(APPLY-ERROR "Too few arguments" (FETCH VAL) (FETCH ARGL)))
((> NARGS NPARAMS)
(APPLY-ERROR "Too many arguments" (FETCH VAL) (FETCH ARGL)))
(T ,@BODY))))
(T ,@BODY)))
(DEFDISPATCH *PROCEDURE* PROCEDURE-CLASS
(WITH-CHECKARGS-COMPOUND
(ASSIGN ENV (MAKE-ENVIRONMENT (FETCH VAL) (FETCH ARGL)))
(COND ((AND (NOT (NULL (FETCH PENDING-INTERRUPTS)))
(FETCH INTERRUPTS-ENABLED))
(NOINTERRUPT T)
(SAVE ENV)
(SETUP-INTERRUPT-HANDLER (CAR (FETCH PENDING-INTERRUPTS)))
(ASSIGN PENDING-INTERRUPTS
(CDR (FETCH PENDING-INTERRUPTS)))
(SETUP-CONTINUATION INTERRUPT-RETURN)
(GOTO INTERNAL-APPLY-DISPATCH))
(T
(ASSIGN EXP (PROCEDURE-BODY (FETCH VAL)))
(CONTINUE-EVALUATING-EXP)
;; (EVAL-DISPATCH)
))))
(DEFCONT INTERRUPT-RETURN (ENV)
(RESTORE ENV)
(ASSIGN EXP (PROCEDURE-BODY (FRAME-PROCEDURE (FETCH ENV))))
(REINSTALL-HISTORY!)
(CONTINUE-EVALUATING-EXP)
;; (EVAL-DISPATCH)
)
(DEFUN SETUP-INTERRUPT-HANDLER (NUMBER)
(SAVE-HISTORY!)
(ASSIGN ARGL (LIST (FETCH INTERRUPTS-ENABLED)
(FETCH PENDING-INTERRUPTS)))
(ASSIGN VAL (CXR NUMBER (FETCH INTERRUPT-VECTOR)))
(ASSIGN INTERRUPTS-ENABLED NIL))
(DEFDISPATCH *EVALUATOR* PROCEDURE-CLASS
(ASSIGN ENV (SECOND-ARGUMENT (FETCH ARGL)))
(ASSIGN EXP (FIRST-ARGUMENT (FETCH ARGL)))
(CONTINUE-EVALUATING-EXP)
;; (EVAL-DISPATCH)
)
(DEFDISPATCH *CONTROL-POINT* PROCEDURE-CLASS
(GOTO DYNAMIC-THROW))
;;; Applicators for primitive (MacLISP) procedures here.
(DECLARE (SPECIAL *ARGS*))
(DEFMACRO WITH-CHECKARGS-FIXED BODY
`(COND ((AND *DEBUG* (SETQ *ARGS* (PROCEDURE-ARGS (FETCH VAL))))
(LET ((NARGS (LENGTH (FETCH ARGL))))
(COND ((< NARGS (CDR *ARGS*))
(APPLY-ERROR "Too few arguments" (FETCH VAL) (FETCH ARGL)))
((> NARGS (CDR *ARGS*))
(APPLY-ERROR "Too many arguments" (FETCH VAL) (FETCH ARGL)))
(T ,@BODY))))
(T ,@BODY)))
(DEFMACRO WITH-CHECKARGS-VARIABLE BODY
`(COND ((AND *DEBUG* (SETQ *ARGS* (PROCEDURE-ARGS (FETCH VAL))))
(LET ((NARGS (LENGTH (FETCH ARGL))))
(COND ((< NARGS (CAR *ARGS*))
(APPLY-ERROR "Too few arguments" (FETCH VAL) (FETCH ARGL)))
((> NARGS (CDR *ARGS*))
(APPLY-ERROR "Too many arguments" (FETCH VAL) (FETCH ARGL)))
(T ,@BODY))))
(T ,@BODY)))
(DEFVAR *LISP-GUARD* NIL)
(DEFMACRO LISP-GUARD (EXP)
`(PROGN
(SETQ *LISP-GUARD* 'T)
,EXP
(SETQ *LISP-GUARD* NIL)))
(DEFUN ANY-DELAYED? (ARGS)
(DO ((A ARGS (CDR A))) ((NULL A) NIL)
(COND ((DELAYED? (CAR A)) (RETURN A)))))
(DEFMACRO DEFPRIMITIVE-UNDELAYED
(PRIMITIVE-TYPE ARG-NUMBER-CHECK ENDTEST LISP-LINKAGE)
(LET ((FORCE-LOOP (CONCAT PRIMITIVE-TYPE '- 'FORCE-LOOP)))
`(PROGN 'COMPILE
(DEFCONT ,FORCE-LOOP ()
(ASSIGN UNEV (ANY-DELAYED? (FETCH UNEV)))
(COND ((,ENDTEST (FETCH UNEV))
(LISP-GUARD
(ASSIGN VAL
(,LISP-LINKAGE (PROCEDURE-OBJECT (FETCH VAL))
(FETCH ARGL))))
(POPJ))
(T
(ASSIGN CONT ,FORCE-LOOP)
(GOTO FORCE-EXP))))
(DEFDISPATCH ,PRIMITIVE-TYPE PROCEDURE-CLASS
(,ARG-NUMBER-CHECK
,PRIMITIVE-TYPE
(ASSIGN EXP (ANY-DELAYED? (FETCH ARGL)))
(COND ((,ENDTEST (FETCH EXP))
(LISP-GUARD
(ASSIGN VAL
(,LISP-LINKAGE (PROCEDURE-OBJECT (FETCH VAL))
(FETCH ARGL))))
(POPJ))
(T
(ASSIGN UNEV (FETCH EXP))
(ASSIGN CONT ,FORCE-LOOP)
(GOTO FORCE-EXP))))))))
(DEFPRIMITIVE-UNDELAYED SUBR WITH-CHECKARGS-FIXED NULL SUBRAPPLY)
(DEFPRIMITIVE-UNDELAYED LSUBR WITH-CHECKARGS-VARIABLE NULL LSUBRAPPLY)
(DEFPRIMITIVE-UNDELAYED EXPR PROGN NULL EXPRAPPLY)
;;; Special versions of application for unforced stuff
;;; For CONS.
(DEFDISPATCH UNFORCED-SUBR PROCEDURE-CLASS
(WITH-CHECKARGS-FIXED
(LISP-GUARD
(ASSIGN VAL (SUBRAPPLY (PROCEDURE-OBJECT (FETCH VAL)) (FETCH ARGL))))
(POPJ)))
;;; For LIST, LIST*
(DEFDISPATCH UNFORCED-LSUBR PROCEDURE-CLASS
(WITH-CHECKARGS-VARIABLE
(LISP-GUARD
(ASSIGN VAL (LSUBRAPPLY (PROCEDURE-OBJECT (FETCH VAL)) (FETCH ARGL))))
(POPJ)))
;;; Special version of application for SET-CAR!, SET-CDR!, ARRAY-SET!,
;;; LOCAL-DEFINE!, PUT-PROP!
(DEFMACRO NULL-CDR (X) `(NULL (CDR ,X)))
(DEFPRIMITIVE-UNDELAYED BUT-1-FORCED-SUBR WITH-CHECKARGS-FIXED NULL-CDR SUBRAPPLY)
;;; Delayed evaluation forcer.
(DEFENTRY FORCE-EXP ()
(COND ((ALREADY-FORCED? (GET-ARG (FETCH UNEV)))
(SET-ARG (FETCH UNEV) (FORCED-VALUE (GET-ARG (FETCH UNEV))))
(CONTINUE))
(T
(SAVE CONT)
(SAVE ARGL)
(SAVE-AFTER-ASSIGN ARGL (FETCH VAL))
(SAVE UNEV)
(ASSIGN EXP (GET-ARG (FETCH UNEV)))
(ASSIGN ENV (DELAYED-ENVIRONMENT (FETCH EXP)))
(ASSIGN EXP (DELAYED-EXPRESSION (FETCH EXP)))
(EVAL-EXP-RESULT-TO UPDATE-DELAYED))))
(DEFCONT UPDATE-DELAYED (UNEV ARGL ARGL)
(RESTORE UNEV)
(SET-FORCED-VALUE (GET-ARG (FETCH UNEV)) (FETCH VAL))
(SET-ARG (FETCH UNEV) (FETCH VAL))
(RESTORE ARGL)
(ASSIGN VAL (FETCH ARGL))
(RESTORE ARGL)
(POPJ))
(DEFENTRY DYNAMIC-THROW ()
(SAVE ARGL) ;Save argument list
(SAVE-AFTER-ASSIGN ARGL (FETCH VAL)) ;and control tag.
(GOTO UNWIND-LOOP))
(DEFCONT UNWIND-LOOP (ARGL ARGL)
(COND ((NULL (FETCH WIND-FORMS))
(GOTO DO-THROW))
(T
(ASSIGN EXP (UNWIND-FORM (CAR (FETCH WIND-FORMS))))
(ASSIGN ENV (DYNAMIC-ENV (CAR (FETCH WIND-FORMS))))
(ASSIGN WIND-FORMS (CDR (FETCH WIND-FORMS))) ;Pop WIND-FORMS.
(EVAL-EXP-RESULT-TO UNWIND-LOOP))))
(DEFENTRY DO-THROW (ARGL ARGL)
(RESTORE ARGL) ;Get back argl and tag
(ASSIGN VAL (FETCH ARGL))
(RESTORE ARGL)
(ASSIGN EXP (FETCH ARGL)) ;Though only stacks are
(RESTORE-CONTROL-POINT (FETCH VAL)) ; clobbered by process switch
(ASSIGN ARGL (FETCH EXP)) ; we do not depend on this.
(SAVE ARGL)
(ASSIGN UNEV (REVERSE (FETCH WIND-FORMS)))
(ASSIGN WIND-FORMS NIL)
(GOTO WIND-LOOP))
(DEFENTRY WIND-LOOP (ARGL)
(COND ((NULL (FETCH UNEV)) ;No more winding to do
(RESTORE ARGL) ;Get back ARGL and return
(ASSIGN VAL (GET-ARG (FETCH ARGL))) ;value to continuation
(POPJ))
(T
(SAVE UNEV)
(ASSIGN ENV (DYNAMIC-ENV (CAR (FETCH UNEV))))
(ASSIGN EXP (WIND-FORM (CAR (FETCH UNEV))))
(EVAL-EXP-RESULT-TO WIND-LOOP-RETURN))))
(DEFCONT WIND-LOOP-RETURN (UNEV ARGL)
(RESTORE UNEV)
(ASSIGN WIND-FORMS
(CONS (CAR (FETCH UNEV))
(FETCH WIND-FORMS)))
(ASSIGN UNEV (CDR (FETCH UNEV)))
(GOTO WIND-LOOP))
;;;; errors
(DEFUN FORCE-INTERRUPT-IF-FROM-LISP (NUMBER)
(COND ((NOT (NULL *LISP-GUARD*))
(SETUP-INTERRUPT-HANDLER NUMBER)
(SETUP-CONTINUATION UNCONTINUABLE)
(SETQ *LISP-GUARD* NIL)
(*THROW 'CONTINUE-SCHEME T))
(T
(ENTER-PRIORITY-INTERRUPT NUMBER))))
(DEFCONT UNCONTINUABLE ()
(VALUE-ERROR "Continued uncontinuable process" NIL))
(DEFUN BUG-SCHEME-ERROR ARGS
(ENTER-LISP-SYSTEM)
(ERROR "SCHEME system error -- Please call a system wizard"
(LISTIFY ARGS)))
(DEFUN PRIMITIVE-ERROR-TRAMPOLINE ARGS
(LET ((E (CADDR (ERRFRAME NIL))))
(SETUP-APPLY-RETRY (LIST (CAR E) (CADR E))
(CONS (FETCH VAL) (FETCH ARGL)))
(COND ((NOT (NULL *LISP-GUARD*))
(FORCE-INTERRUPT-IF-FROM-LISP 1))
(T
(BUG-SCHEME-ERROR "From TRAMPOLINE" (ERRFRAME NIL) (LISTIFY ARGS))))))
(DEFUN SCH-ERROR ARGS
(LET ((A (LISTIFY ARGS)))
(SETUP-APPLY-RETRY (CAR A) (CADR A))
(COND ((NOT (NULL *LISP-GUARD*))
(FORCE-INTERRUPT-IF-FROM-LISP 1))
(T
(BUG-SCHEME-ERROR "From SCH-ERROR" (LISTIFY ARGS))))))
(DEFUN SCH-PDL-OVERFLOW (STACK)
(SETUP-APPLY-RETRY "Stack overflow in primitive procedure" STACK)
(COND ((NOT (NULL *LISP-GUARD*))
(FORCE-INTERRUPT-IF-FROM-LISP 1))
(T
(BUG-SCHEME-ERROR "PDL overflow" STACK))))
;;; garbage collector
(DEFUN SCH-GC-LOSSAGE (SPACE)
(ENTER-LISP-SYSTEM)
(ERROR "Space exceeded beyond recuperation -- YOU LOSE" SPACE))
(DEFUN SCH-GC-OVERFLOW (SPACE)
(ENTER-LISP-SYSTEM)
(ERROR "Space exceeded beyond recuperation -- YOU LOSE" SPACE))
(DEFVAR *MAX-RECURSION-DEPTH* 1000.)
(DEFUN CHECK-RECURSION-DEPTH ()
(IF (> (LENGTH (READ-STACK CONT)) *MAX-RECURSION-DEPTH*)
(PROGN (SET-GLOBAL-VALUE '*message*
"Warning: Recursion depth limit exceeded. Proceed from break if OK")
(SET-GLOBAL-VALUE '*IRRITANT* *max-recursion-depth*)
(ENTER-INTERRUPT 3))))
;;; The following are common sequences of operations used when
;;; signalling execution errors:
(DEFUN IMMEDIATE-INTERRUPT (NUMBER)
(SETUP-INTERRUPT-HANDLER NUMBER)
(GOTO INTERNAL-APPLY-DISPATCH))
(DEFUN EVAL-ERROR (MESSAGE IRRITANT)
(SAVE ENV)
(SAVE-AFTER-ASSIGN UNEV (FETCH EXP))
(SETUP-CONTINUATION DO-EVAL)
(SET-GLOBAL-VALUE '*MESSAGE* MESSAGE)
(SET-GLOBAL-VALUE '*IRRITANT* IRRITANT)
(IMMEDIATE-INTERRUPT 2))
(DEFCONT DO-EVAL (UNEV ENV)
(RESTORE UNEV)
(ASSIGN EXP (FETCH UNEV))
(RESTORE ENV)
;; (EVAL-DISPATCH)
)
(DEFUN VALUE-ERROR (MESSAGE IRRITANT)
(SAVE CONT)
(SAVE ARGL)
(SAVE-AFTER-ASSIGN UNEV (FETCH VAL))
(SETUP-CONTINUATION DO-CONTINUE)
(SET-GLOBAL-VALUE '*MESSAGE* MESSAGE)
(SET-GLOBAL-VALUE '*IRRITANT* IRRITANT)
(IMMEDIATE-INTERRUPT 2))
(DEFCONT DO-CONTINUE (ARGL UNEV)
(RESTORE UNEV)
(ASSIGN VAL (FETCH UNEV))
(RESTORE ARGL)
(POPJ))
(DEFUN APPLY-ERROR (MESSAGE PROC ARGS)
(SETUP-APPLY-RETRY MESSAGE (CONS PROC ARGS))
(IMMEDIATE-INTERRUPT 2))
(DEFUN SETUP-APPLY-RETRY (MESSAGE IRRITANT)
(SET-GLOBAL-VALUE '*MESSAGE* MESSAGE)
(SET-GLOBAL-VALUE '*IRRITANT* IRRITANT)
(SAVE ARGL)
(SAVE-AFTER-ASSIGN UNEV (FETCH VAL))
(SETUP-CONTINUATION DO-APPLY))
(DEFCONT DO-APPLY (UNEV ARGL)
(RESTORE UNEV)
(ASSIGN VAL (FETCH UNEV))
(GOTO INTERNAL-APPLY))
;;;; asynchronous interrupts
(DEFUN SCH-↑B-HANDLER (STREAM NIL)
(CLEAR-INPUT STREAM)
(PRINC "↑B")
(ENTER-INTERRUPT 4.))
(DEFUN SCH-↑G-HANDLER (STREAM NIL)
(CLEAR-INPUT STREAM)
(PRINC "↑G")
(ASSIGN PENDING-INTERRUPTS NIL)
(FORCE-INTERRUPT-IF-FROM-LISP 5.))
(DEFUN SCH-↑U-HANDLER (STREAM NIL)
(CLEAR-INPUT STREAM)
(PRINC "↑U")
(ASSIGN PENDING-INTERRUPTS NIL)
(FORCE-INTERRUPT-IF-FROM-LISP 6.))
(DEFUN SCH-↑X-HANDLER (STREAM NIL)
(CLEAR-INPUT STREAM)
(PRINC "↑X")
(IF (MEMBER 4. (FETCH PENDING-INTERRUPTS)) ;↑B Pending?
(PROGN (ASSIGN PENDING-INTERRUPTS
(DELETE 4.
(FETCH PENDING-INTERRUPTS)))
(FORCE-INTERRUPT-IF-FROM-LISP 4.))
(PROGN (ASSIGN PENDING-INTERRUPTS NIL)
(FORCE-INTERRUPT-IF-FROM-LISP 7.))))
;;; Entering and Enabling Interrupts
(DEFUN-IMPORT ENTER-INTERRUPT (INTERRUPT-NUMBER)
(LET ((SI (NOINTERRUPT T))) ;Critical section
(IF (MEMBER INTERRUPT-NUMBER (FETCH PENDING-INTERRUPTS))
NIL
(ASSIGN PENDING-INTERRUPTS
(NCONC (FETCH PENDING-INTERRUPTS)
(LIST INTERRUPT-NUMBER))))
(NOINTERRUPT SI)))
(DEFUN-IMPORT ENTER-PRIORITY-INTERRUPT (INTERRUPT-NUMBER)
(LET ((SI (NOINTERRUPT T)))
(ASSIGN PENDING-INTERRUPTS
(CONS INTERRUPT-NUMBER
(DELETE INTERRUPT-NUMBER
(FETCH PENDING-INTERRUPTS))))
(NOINTERRUPT SI)))
;;; The following primitive allows a user to control the enabling
;;; of interrupts, thus allowing him to make critical sections.
(DEFUN-IMPORT SET-INTERRUPTS-ENABLED (E)
(NOINTERRUPT T)
(LET ((IE (FETCH INTERRUPTS-ENABLED)))
(ASSIGN INTERRUPTS-ENABLED E)
(NOINTERRUPT (NOT E))
IE))
;;; APPLY of a SCHEME procedure must escape from the current control structure.
(DEFUN-IMPORT (APPLY SCHAPPLY) (PROC ARGS)
(COND ((NOT (OR (NULL ARGS) (PAIRP ARGS)))
(SCH-ERROR "Illformed argument list -- APPLY" (CONS PROC ARGS)))
(T
(ASSIGN ARGL ARGS)
(ASSIGN VAL PROC)
(SETQ *LISP-GUARD* NIL)
(*THROW 'CONTINUE-SCHEME NIL))))
;;;; the microcode top level
(DEFCONT DONE ()
(SETQ *LISP-GUARD* NIL)
(*THROW 'DONE (FETCH VAL)))
;;; RUN takes input from LISP and runs the interpreter.
(DEFUN RUN (INPUT)
(RESET-RACKS) ;clear universe
(ASSIGN WIND-FORMS NIL)
(SETUP-CONTINUATION DONE) ;subr flag
(ASSIGN PENDING-INTERRUPTS NIL)
(ASSIGN INTERRUPTS-ENABLED NIL)
(ASSIGN INTERRUPT-VECTOR
(INLOC (GLOBAL-VCELL 'SYSTEM-INTERRUPT-VECTOR)))
(RUN-SCHEME INPUT))
(DEFUN RUN-SCHEME (INPUT)
(ASSIGN EXP INPUT)
(ASSIGN ENV NIL)
(ENTER-SCHEME-SYSTEM) ;Setup system variables.
(LET ((RESULT (SPIN-THE-WHEELS)))
(ENTER-LISP-SYSTEM)
RESULT))
(DEFUN SPIN-THE-WHEELS ()
(*CATCH 'DONE
(PROG NIL
EVLP (IF (*CATCH 'CONTINUE-SCHEME (MAIN-LOOP))
(NOINTERRUPT T))
APLP (IF (*CATCH 'CONTINUE-SCHEME
(PROGN (GOTO INTERNAL-APPLY-DISPATCH)
(GO EVLP)))
(NOINTERRUPT T))
(GO APLP))))
(DEFUN MAIN-LOOP ()
(DO () (NIL) ;Forever!
(EVAL-DISPATCH)))
;;; Transferring between LISP and SCHEME
(DEFUN-IMPORT SCHEME-TO-LISP ()
(SETQ *LISP-GUARD* NIL)
(*THROW 'DONE 'SCHEME-TO-LISP))
;;; To reenter SCHEME from a MACLISP state
(DEFUN CONTINUE-SCHEME ()
(RUN-SCHEME '(QUOTED T)))
;;;; Taking over the MacLISP error system:
(DECLARE (SPECIAL *SYSTEM-VARIABLES* *LISP-SYSTEM*))
(DECLARE (SPECIAL BACKQUOTE-EXPAND-WHEN UNDF-FNCTN UNBND-VRBL WRNG-TYPE-ARG
UNSEEN-GO-TAG WRNG-NO-ARGS FAIL-ACT *RSET-TRAP ERRSET
IO-LOSSAGE PDL-OVERFLOW GC-LOSSAGE GC-OVERFLOW GC-DAEMON))
(SETQ *SYSTEM-VARIABLES*
'(BACKQUOTE-EXPAND-WHEN UNDF-FNCTN UNBND-VRBL WRNG-TYPE-ARG
UNSEEN-GO-TAG WRNG-NO-ARGS FAIL-ACT *RSET-TRAP ERRSET
IO-LOSSAGE PDL-OVERFLOW GC-LOSSAGE GC-OVERFLOW GC-DAEMON
(TTYINT #↑B) (TTYINT #↑D) (TTYINT #↑G)
(TTYINT #↑U) (TTYINT #↑W) (TTYINT #↑X) (TTYINT #↑Z) ))
(DEFUN GET-SYSTEM-VALUE (V)
(COND ((SYMBOLP V) (SYMEVAL V))
((EQ (CAR V) 'TTYINT)
(EVAL `(STATUS TTYINT ',(CADR V))))
(T (BREAK "GET-SYSTEM-VALUE"))))
(DEFUN SET-SYSTEM-VALUE (VAR VAL)
(COND ((SYMBOLP VAR) (SET VAR VAL))
((EQ (CAR VAR) 'TTYINT)
(EVAL `(SSTATUS TTYINT ',(CADR VAR) ',VAL)))
(T (BREAK "SET-SYSTEM-VALUE"))))
(SETQ *LISP-SYSTEM*
(MAPCAR #'(LAMBDA (V)
(LIST V (GET-SYSTEM-VALUE V)))
*SYSTEM-VARIABLES*))
(DEFUN ENTER-LISP-SYSTEM ()
(MAPC #'(LAMBDA (X) (SET-SYSTEM-VALUE (CAR X) (CADR X)))
*LISP-SYSTEM*)
)
(DEFUN ENTER-SCHEME-SYSTEM ()
(MAPC #'(LAMBDA (X) (SET-SYSTEM-VALUE (CAR X) (CADR X)))
`(#M(BACKQUOTE-EXPAND-WHEN READ)
#M(UNDF-FNCTN ,#'PRIMITIVE-ERROR-TRAMPOLINE)
#M(UNBND-VRBL ,#'PRIMITIVE-ERROR-TRAMPOLINE)
#M(WRNG-TYPE-ARG ,#'PRIMITIVE-ERROR-TRAMPOLINE)
#M(UNSEEN-GO-TAG ,#'PRIMITIVE-ERROR-TRAMPOLINE)
#M(WRNG-NO-ARGS ,#'PRIMITIVE-ERROR-TRAMPOLINE)
#M(FAIL-ACT ,#'PRIMITIVE-ERROR-TRAMPOLINE)
#M(IO-LOSSAGE ,#'PRIMITIVE-ERROR-TRAMPOLINE)
#M(*RSET-TRAP ,#'PRIMITIVE-ERROR-TRAMPOLINE)
; #M(ERRSET ,#'SCH-ERRSET)
#M(PDL-OVERFLOW ,#'SCH-PDL-OVERFLOW)
; #M(GC-OVERFLOW ,#'SCH-GC-OVERFLOW)
#M(GC-LOSSAGE ,#'SCH-GC-LOSSAGE)
#M(GC-DAEMON '(LAMBDA (X)
(gc-overflow-DAEMON X)
(CHECK-RECURSION-DEPTH)))
#M((TTYINT #↑B) ,#'SCH-↑B-HANDLER)
#M((TTYINT #↑D) NIL) ;turn off ↑D
#M((TTYINT #↑G) ,#'SCH-↑G-HANDLER)
#M((TTYINT #↑U) ,#'SCH-↑U-HANDLER)
#M((TTYINT #↑W) NIL) ;remove ↑W
#M((TTYINT #↑X) ,#'SCH-↑X-HANDLER)
#M((TTYINT #↑Z) NIL) ;remove ↑Z
))
)
;;;; Variable lookup routines
(DEFUN SETUP-LEXICAL-ADDRESS (VARNAME)
(DO ((FR (FETCH ENV) (PREVIOUS-FRAME FR))
(FN 0 (1+ FN))
(VC NIL))
((NULL FR)
(COND ((SETQ VC (GLOBAL-VCELL VARNAME))
(COND ((NOT (DANGEROUS-GLOBAL? VC))
(COMPILE-GLOBAL (FETCH EXP))))))
VC)
(DO ((AVARS (AUX-VARIABLES FR) (CDR AVARS))
(AVALS (AUX-VALUES FR) (CDR AVALS))
(AFLAGS (AUX-FLAGS FR) (CDR AFLAGS)) ;could be nil
(DN 0 (1+ DN)))
((NULL AVARS) NIL)
(COND ((EQ VARNAME (CAR AVARS))
(SETQ VC AVALS)
(COND ((NOT (DANGEROUS? (CAR AFLAGS))) ;could be nil
(COMPILE-AUXILIARY (FETCH EXP) FN DN FR)))
(RETURN NIL))))
(COND ((NOT (NULL VC)) (RETURN VC)))
(DO ((FVARS (FRAME-FORMALS FR) (CDR FVARS))
(FVALS (FRAME-ARGUMENTS FR) (CDR FVALS))
(FFLAGS (FRAME-FLAGS FR) (CDR FFLAGS)) ;could be nil
(DN 0 (1+ DN)))
((NULL FVARS) NIL)
(COND ((EQ VARNAME (CAR FVARS))
(SETQ VC FVALS)
(COND ((NOT (DANGEROUS? (CAR FFLAGS))) ;could be nil
(COMPILE-FORMAL (FETCH EXP) FN DN)))
(RETURN NIL))))
(COND ((NOT (NULL VC)) (RETURN VC)))))
(DEFUN GET-FORMAL-VCELL (LEXICAL-ADDRESS)
(LET ((FRAME (NTH-FRAME (FRAME-NUMBER LEXICAL-ADDRESS) (FETCH ENV))))
(COND ((NOT (DANGEROUS? (NTH (DISPLACEMENT-NUMBER LEXICAL-ADDRESS)
(FRAME-FLAGS FRAME))))
(NTHCDR (DISPLACEMENT-NUMBER LEXICAL-ADDRESS)
(FRAME-ARGUMENTS FRAME)))
(T NIL))))
(DEFUN GET-AUXILIARY-VCELL (VARSPEC)
(LET ((LEXICAL-ADDRESS (LEXICAL-ADDRESS VARSPEC)))
(LET ((FRAME (NTH-FRAME (FRAME-NUMBER LEXICAL-ADDRESS) (FETCH ENV))))
(COND ((AND (EQ (ENVIRONMENT-IDENTIFIER VARSPEC) FRAME)
(NOT (DANGEROUS? (NTH (DISPLACEMENT-NUMBER LEXICAL-ADDRESS)
(AUX-FLAGS FRAME)))))
(NTHCDR (DISPLACEMENT-NUMBER LEXICAL-ADDRESS)
(AUX-VALUES FRAME)))
(T NIL)))))
(DEFUN GET-GLOBAL-VCELL (VARNAME)
(LET ((VC (GLOBAL-VCELL VARNAME)))
(IF (DANGEROUS-GLOBAL? VC)
NIL
VC)))
(DEFUN NTH-FRAME (FN FR)
(declare (fixnum fn))
(DO ((F FR (PREVIOUS-FRAME F))
(N FN (1- N)))
((NULL F)
(BUG-SCHEME-ERROR "Bad frame number -- NTH-FRAME"))
(declare (fixnum n))
(COND ((= N 0) (RETURN F)))))
(DEFUN-IMPORT (LOCAL-DEFINE! LOCAL-DEFINE! BUT-1-FORCED-SUBR) (FR VAR VAL)
(COND ((GLOBAL-ENVIRONMENT? FR)
(COND ((GET VAR 'POTENTIALLY-DANGEROUS)
(REMPROP VAR 'POTENTIALLY-DANGEROUS)
(MAKE-DANGEROUS-GLOBAL VAR)))
(SET-GLOBAL-VALUE VAR VAL))
((NOT (FRAME? FR))
(SCH-ERROR "Bad environment -- LSET" FR))
((DO ((AVARS (AUX-VARIABLES FR) (CDR AVARS))
(AVALS (AUX-VALUES FR) (CDR AVALS)))
((NULL AVARS) NIL)
(COND ((EQ VAR (CAR AVARS))
(SETLOC AVALS VAL)
(RETURN T)))))
(T
(ADD-AUX-VARIABLE VAR VAL FR))))
(DEFUN ADD-AUX-VARIABLE (VAR VAL ENV)
(SET-AUX-VARIABLES ENV (NCONC (AUX-VARIABLES ENV) (LIST VAR)))
(SET-AUX-VALUES ENV (NCONC (AUX-VALUES ENV) (LIST VAL)))
(COND ((POTENTIALLY-DANGEROUS? VAR ENV)
(REMOVE-FROM-POTENTIALLY-DANGEROUS VAR ENV)
(MAKE-AUX-VARIABLE-DANGEROUS VAR ENV))
((MEMQ VAR (FRAME-FORMALS ENV))
(MAKE-FORMAL-DANGEROUS VAR ENV))
(T (WARN-PARENT-ENVIRONMENTS VAR (PREVIOUS-FRAME ENV)))))
(DEFUN WARN-PARENT-ENVIRONMENTS (VAR ENV)
(COND ((GLOBAL-ENVIRONMENT? ENV) (WARN-GLOBAL-ENVIRONMENT VAR))
((MEMQ VAR (AUX-VARIABLES ENV))
(MAKE-AUX-VARIABLE-DANGEROUS VAR ENV))
((MEMQ VAR (FRAME-FORMALS ENV))
(MAKE-FORMAL-DANGEROUS VAR ENV))
((MAKE-POTENTIALLY-DANGEROUS VAR ENV)
(WARN-PARENT-ENVIRONMENTS VAR (PREVIOUS-FRAME ENV)))
(T NIL)))
(DEFUN MAKE-AUX-VARIABLE-DANGEROUS (VAR ENV)
(SET-AUX-FLAGS ENV
(ADD-FLAG VAR
(AUX-VARIABLES ENV)
(AUX-FLAGS ENV)
'DANGEROUS)))
(DEFUN MAKE-FORMAL-DANGEROUS (VAR ENV)
(SET-FRAME-FLAGS ENV
(ADD-FLAG VAR
(FRAME-FORMALS ENV)
(FRAME-FLAGS ENV)
'DANGEROUS)))
(DEFUN ADD-FLAG (VAR VARLIST FLAGLIST FLAG)
(COND ((NULL FLAGLIST) (SETQ FLAGLIST (LIST NIL))))
(DO ((VL VARLIST (CDR VL))
(FL FLAGLIST (OR (CDR FL) (PROGN (RPLACD FL (LIST NIL)) (CDR FL)))))
((EQ VAR (CAR VL))
(OR (MEMQ FLAG (CAR FL))
(RPLACA FL (CONS FLAG (CAR FL))))
FLAGLIST)))
(DEFUN WARN-GLOBAL-ENVIRONMENT (VAR)
(COND ((GLOBALLY-BOUND? VAR)
(MAKE-DANGEROUS-GLOBAL VAR))
(T (PUTPROP VAR T 'POTENTIALLY-DANGEROUS))))
(DEFUN-IMPORT RELATIVE-LEXICAL-ACCESS (ENV VAR)
(IF (NOT (ENVIRONMENT? ENV))
(SCH-ERROR "Bad Environment" ENV))
(DO ((FR ENV (PREVIOUS-FRAME FR)) (VC NIL))
((NULL FR)
(COND ((SETQ VC (GLOBAL-VCELL VAR))
(INLOC VC))
(T
(SCH-ERROR "Unbound variable -- ACCESS" VAR))))
(DO ((AVARS (AUX-VARIABLES FR) (CDR AVARS))
(AVALS (AUX-VALUES FR) (CDR AVALS)))
((NULL AVARS) NIL)
(COND ((EQ VAR (CAR AVARS)) (SETQ VC AVALS) (RETURN NIL))))
(COND ((NOT (NULL VC)) (RETURN (INLOC VC))))
(DO ((FVARS (FRAME-FORMALS FR) (CDR FVARS))
(FVALS (FRAME-ARGUMENTS FR) (CDR FVALS)))
((NULL FVARS) NIL)
(COND ((EQ VAR (CAR FVARS)) (SETQ VC FVALS) (RETURN NIL))))
(COND ((NOT (NULL VC)) (RETURN (INLOC VC))))))
(DEFUN-IMPORT LOCATE-AUXILIARY-PATHNAME (FRAME NAME)
(DO ((AVARS (AUX-VARIABLES FRAME) (CDR AVARS))
(AVALS (AUX-VALUES FRAME) (CDR AVALS)))
((NULL AVARS) NIL)
(IF (EQ NAME (CAR AVARS))
(RETURN (CAR AVALS)))))
(DEFUN-IMPORT
(RELATIVE-LEXICAL-ASSIGN RELATIVE-LEXICAL-ASSIGN BUT-1-FORCED-SUBR)
(ENV VAR VAL)
(IF (NOT (ENVIRONMENT? ENV))
(SCH-ERROR "Bad Environment" ENV))
(DO ((FR ENV (PREVIOUS-FRAME FR)) (VC NIL))
((NULL FR)
(COND ((SETQ VC (GLOBAL-VCELL VAR))
(SETLOC VC VAL)
T)
(T
(SCH-ERROR "Unbound variable -- ACCESS" VAR))))
(DO ((AVARS (AUX-VARIABLES FR) (CDR AVARS))
(AVALS (AUX-VALUES FR) (CDR AVALS)))
((NULL AVARS) NIL)
(COND ((EQ VAR (CAR AVARS)) (SETQ VC AVALS) (RETURN NIL))))
(COND ((NOT (NULL VC)) (SETLOC VC VAL) (RETURN T)))
(DO ((FVARS (FRAME-FORMALS FR) (CDR FVARS))
(FVALS (FRAME-ARGUMENTS FR) (CDR FVALS)))
((NULL FVARS) NIL)
(COND ((EQ VAR (CAR FVARS)) (SETQ VC FVALS) (RETURN NIL))))
(COND ((NOT (NULL VC)) (SETLOC VC VAL) (RETURN T)))))
(DEFUN UNCOMPILE-LEXICAL (VAR)
(LET ((SI (NOINTERRUPT T)))
(SELECTQ (TYPE VAR)
((LEXICAL-UNCOMPILED ASSIGN-UNCOMPILED) VAR)
((GLOBAL ASSIGN-GLOBAL)
(REPLACE-VARIABLE-TYPE VAR 'LEXICAL-UNCOMPILED))
((LEXICAL-FORMAL LEXICAL-AUXILIARY)
(REPLACE-VARIABLE-TYPE VAR 'LEXICAL-UNCOMPILED)
(REPLACE-VARSPEC VAR (VARIABLE-NAME (VARSPEC VAR))))
((ASSIGN-FORMAL ASSIGN-AUXILIARY)
(REPLACE-VARIABLE-TYPE VAR 'ASSIGN-UNCOMPILED)
(REPLACE-ASSIGN-VARSPEC VAR (VARIABLE-NAME (ASSIGN-VARSPEC VAR))))
(T (BUG-SCHEME-ERROR "Bad variable -- UNCOMPILE-LEXICAL" VAR)))
(NOINTERRUPT SI)))
(DEFUN COMPILE-FORMAL (VAR FN DN)
(LET ((SI (NOINTERRUPT T)))
(SELECTQ (TYPE VAR)
((LEXICAL-UNCOMPILED GLOBAL)
(REPLACE-VARIABLE-TYPE VAR 'LEXICAL-FORMAL)
(REPLACE-VARSPEC VAR (MAKE-VARSPEC FN DN (VARSPEC VAR) NIL)))
(LEXICAL-AUXILIARY
(REPLACE-VARIABLE-TYPE VAR 'LEXICAL-FORMAL)
(REPLACE-VARSPEC VAR
(MAKE-VARSPEC FN DN (VARIABLE-NAME (VARSPEC VAR)) NIL)))
((ASSIGN-UNCOMPILED ASSIGN-GLOBAL)
(REPLACE-VARIABLE-TYPE VAR 'ASSIGN-FORMAL)
(REPLACE-ASSIGN-VARSPEC VAR
(MAKE-VARSPEC FN DN (ASSIGN-VARSPEC VAR) NIL)))
(ASSIGN-AUXILIARY
(REPLACE-VARIABLE-TYPE VAR 'ASSIGN-FORMAL)
(REPLACE-ASSIGN-VARSPEC VAR
(MAKE-VARSPEC FN DN (VARIABLE-NAME (ASSIGN-VARSPEC VAR)) NIL)))
(T (BUG-SCHEME-ERROR "Bad variable -- COMPILE-FORMAL" VAR)))
(NOINTERRUPT SI)))
(DEFUN COMPILE-AUXILIARY (VAR FN DN ENV-ID)
(LET ((SI (NOINTERRUPT T)))
(SELECTQ (TYPE VAR)
((LEXICAL-UNCOMPILED GLOBAL)
(REPLACE-VARIABLE-TYPE VAR 'LEXICAL-AUXILIARY)
(REPLACE-VARSPEC VAR (MAKE-VARSPEC FN DN (VARSPEC VAR) ENV-ID)))
(LEXICAL-FORMAL
(REPLACE-VARIABLE-TYPE VAR 'LEXICAL-AUXILIARY)
(REPLACE-VARSPEC VAR
(MAKE-VARSPEC FN DN (VARIABLE-NAME (VARSPEC VAR)) ENV-ID)))
((ASSIGN-UNCOMPILED ASSIGN-GLOBAL)
(REPLACE-VARIABLE-TYPE VAR 'ASSIGN-AUXILIARY)
(REPLACE-ASSIGN-VARSPEC VAR
(MAKE-VARSPEC FN DN (ASSIGN-VARSPEC VAR) ENV-ID)))
(ASSIGN-FORMAL
(REPLACE-VARIABLE-TYPE VAR 'ASSIGN-AUXILIARY)
(REPLACE-ASSIGN-VARSPEC VAR
(MAKE-VARSPEC FN DN (VARIABLE-NAME (ASSIGN-VARSPEC VAR)) ENV-ID)))
(T (BUG-SCHEME-ERROR "Bad variable -- COMPILE-AUXILIARY" VAR)))
(NOINTERRUPT SI)))
(DEFUN COMPILE-GLOBAL (VAR)
(LET ((SI (NOINTERRUPT T)))
(SELECTQ (TYPE VAR)
(LEXICAL-UNCOMPILED
(REPLACE-VARIABLE-TYPE VAR 'GLOBAL))
(ASSIGN-UNCOMPILED
(REPLACE-VARIABLE-TYPE VAR 'ASSIGN-GLOBAL))
((LEXICAL-FORMAL LEXICAL-AUXILIARY)
(REPLACE-VARIABLE-TYPE VAR 'GLOBAL)
(REPLACE-VARSPEC VAR (VARIABLE-NAME (VARSPEC VAR))))
((ASSIGN-FORMAL ASSIGN-AUXILIARY)
(REPLACE-VARIABLE-TYPE VAR 'ASSIGN-GLOBAL)
(REPLACE-ASSIGN-VARSPEC VAR
(VARIABLE-NAME (ASSIGN-VARSPEC VAR))))
(T (BUG-SCHEME-ERROR "Bad variable -- COMPILE-GLOBAL" VAR)))
(NOINTERRUPT SI)))
;;;; Hairy control structure primitives
(DEFUN MAKE-CONTROL-POINT ()
(MAKE-HUNK '*CONTROL-POINT*
(GET-STATE CONT)
(GET-STATE DELAYED-OBJECT)
(GET-STATE ARGL)
(GET-STATE ENV)
(GET-STATE VCELL)
(GET-STATE UNEV)
(FETCH WIND-FORMS)))
(DEFUN RESTORE-CONTROL-POINT (P)
(SET-STATE CONT (CXR 2 P))
(SET-STATE DELAYED-OBJECT (CXR 3 P))
(SET-STATE ARGL (CXR 4 P))
(SET-STATE ENV (CXR 5 P))
(SET-STATE VCELL (CXR 6 P))
(SET-STATE UNEV (CXR 7 P))
(ASSIGN WIND-FORMS (CXR 0 P)))
(DEFUN CONTROL-POINT-CONT (P) (CXR 2 P))
(DEFUN CONTROL-POINT-DELAYED-OBJECT (P) (CXR 3 P))
(DEFUN CONTROL-POINT-ARGL (P) (CXR 4 P))
(DEFUN CONTROL-POINT-ENV (P) (CXR 5 P))
(DEFUN CONTROL-POINT-VCELL (P) (CXR 6 P))
(DEFUN CONTROL-POINT-UNEV (P) (CXR 7 P))
(DEFUN CONTROL-POINT-WIND-FORMS (P) (CXR 0 P))
;;;; Speedup hacks -- implementation dependent.
#M(DEFUN EXPRAPPLY (FN VALS) ; let MacLISP APPLY do argument nmbr. checks
(PROG (A B C D E TEMP)
(OR VALS (RETURN (FUNCALL FN)))
(SETQ A (CAR VALS) TEMP VALS VALS (CDR VALS))
(OR VALS (RETURN (FUNCALL FN A)))
(SETQ B (CAR VALS) VALS (CDR VALS))
(OR VALS (RETURN (FUNCALL FN A B)))
(SETQ C (CAR VALS) VALS (CDR VALS))
(OR VALS (RETURN (FUNCALL FN A B C)))
(SETQ D (CAR VALS) VALS (CDR VALS))
(OR VALS (RETURN (FUNCALL FN A B C D)))
(SETQ E (CAR VALS) VALS (CDR VALS))
(OR VALS (RETURN (FUNCALL FN A B C D E)))
(RETURN (APPLY FN TEMP))))
#Q(DEFUN EXPRAPPLY (FN VALS)
(APPLY FN VALS))
#M(DEFUN SUBRAPPLY (FN VALS)
(PROG (A B C D E)
(OR VALS (RETURN (SUBRCALL NIL FN)))
(SETQ A (CAR VALS) VALS (CDR VALS))
(OR VALS (RETURN (SUBRCALL NIL FN A)))
(SETQ B (CAR VALS) VALS (CDR VALS))
(OR VALS (RETURN (SUBRCALL NIL FN A B)))
(SETQ C (CAR VALS) VALS (CDR VALS))
(OR VALS (RETURN (SUBRCALL NIL FN A B C)))
(SETQ D (CAR VALS) VALS (CDR VALS))
(OR VALS (RETURN (SUBRCALL NIL FN A B C D)))
(SETQ E (CAR VALS) VALS (CDR VALS))
(OR VALS (RETURN (SUBRCALL NIL FN A B C D E)))
(BUG-SCHEME-ERROR "Too Many Arguments to a Subr"
(append (list (subr FN) A B C D E) VALS))))
#Q(DEFUN SUBRAPPLY (FN VALS)
(APPLY FN VALS))
#M(DEFUN LSUBRAPPLY (FN VALS)
(PROG (A B C D E TEMP)
(SETQ TEMP VALS)
(OR TEMP (RETURN (LSUBRCALL NIL FN)))
(SETQ A (CAR TEMP) TEMP (CDR TEMP))
(OR TEMP (RETURN (LSUBRCALL NIL FN A)))
(SETQ B (CAR TEMP) TEMP (CDR TEMP))
(OR TEMP (RETURN (LSUBRCALL NIL FN A B)))
(SETQ C (CAR TEMP) TEMP (CDR TEMP))
(OR TEMP (RETURN (LSUBRCALL NIL FN A B C)))
(SETQ D (CAR TEMP) TEMP (CDR TEMP))
(OR TEMP (RETURN (LSUBRCALL NIL FN A B C D)))
(SETQ E (CAR TEMP) TEMP (CDR TEMP))
(OR TEMP (RETURN (LSUBRCALL NIL FN A B C D E)))
(PUTPROP 'THE-LSUBR-APPLY-ATOM FN 'LSUBR)
(RETURN (APPLY 'THE-LSUBR-APPLY-ATOM VALS))))